home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
fileat.zip
/
FA.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1993-01-04
|
13KB
|
364 lines
(****************************************************************************)
(* *)
(* File Attribute Utility version 4.0 *)
(* by Steve Trace OPUS & Fido Net 157/1 *)
(* *)
(* version 4 *)
(* Modified to run under Turbo Pascal 4.0 *)
(* Utilizes 4.0 directory routines. *)
(* Improved message on current path. *)
(* CHMOD now only used to change attribute. *)
(* Improved syntax message when error occurs. *)
(* *)
(* version 3 *)
(* never existed jumped to 4.0 to remain consistant with Borland *)
(* *)
(* version 2a *)
(* Same as version 2 but included documentation file FILEATTR.DOC *)
(* *)
(* version 2 *)
(* Allowed directories to be hidden *)
(* Allowed for use of full path on file spec *)
(* *)
(* version 1 *)
(* Original version changed only files in current directory *)
(* *)
(****************************************************************************)
{$R-,S-,I+,D+,T+,F-,V-,B-,N-,L+ }
{$M 2048,0,4096}
program File_Attribute_Version_4;
{ Manipulates DOS file & directory attributes
(Hidden, System, Archive, Read Only) }
uses DOS;
type
changeType = (no,on,off);
attrType = (arc,sys,hid,r_o);
attrArray = array[attrType] of changeType;
const
mask : attrArray = (no,no,no,no); { typed constant default to no change }
changeAttr : boolean = false; { " " default to not changed }
changed : word = 0;
count : word = 0;
var
fData : searchRec;
f : file;
origAttr : byte;
dir : boolean;
fileSpec,
path : string;
i : word;
procedure syntaxError;
begin
writeln('Syntax Error!');
writeln;
writeln('A>[d:][path\]FA [options] [d:][path\]fileSpec [options]');
writeln;
writeln('options *A -Archive');
writeln(' *H -Hidden');
writeln(' *R -Read Only');
writeln(' *S -System');
writeln;
writeln('replace * with (+) to set attribute');
writeln(' (-) to turn off attribute');
writeln;
writeln;
writeln;
writeln;
writeln;
writeln;
writeln;
writeln;
halt;
end;
function upcaseStr(s : string) : string;
var
i : word; { function converts string to upper case chacters }
begin
for i := 1 to length(s) do
s[i] := upCase(s[i]);
upcaseStr := s;
end;
function DOSVersionOk : boolean;
var
regs : registers;
begin
with regs do
begin
ah := $30; { DOS function hex 30 returns dos version }
MsDos(regs); { in al register }
if al >= 2 then { this program requires DOS 2.0 or higher }
DOSVersionOk := true
else
begin
DOSVersionOk := false;
writeln('FA Requires DOS 2.0 or Higher'); { if DOS 1.x print error msg }
end;
end;
end;
procedure error;
begin
write('DOS Error: ',dosError:1,'- ');
case dosError of
2 : writeln('File not found');
3 : writeln('Path not found');
4 : writeln('Too many files open');
5 : writeln('Access denied');
6 : writeln('Invalid handle');
8 : writeln('Not enough memory');
10 : writeln('Invalid environment');
11 : writeln('Invalid format');
15 : writeln('Invalid drive');
18 : writeln('File not found or invalid drive');
100 : writeln('Disk read error');
101 : writeln('Disk write error');
150 : writeln('Disk write-protected');
152 : writeln('Disk drive not ready');
else writeln('Unknown error');
end;
halt;
end;
procedure SetChange(mark : char; bit : attrType; var mask : attrArray);
{ mark mask with desired changes }
begin
if mark = '+' then { if desire on then }
mask[bit] := on { change portion of mask on }
else
mask[bit] := off; { else set it off }
end;
procedure MarkChange(mark, code : char; var mask : attrArray);
{ change mask modified if change requested }
begin
changeAttr := true;
case code of
'S' : SetChange(mark,sys,mask);
'H' : SetChange(mark,hid,mask);
'R' : SetChange(mark,r_o,mask);
'A' : SetChange(mark,arc,mask);
else syntaxError; { if bad parameter passed then Print Syntax }
end;
end;
function extractPath(fileSpec : string) : string;
var
path : string; { Make path acceptable to DOS function Calls }
{ and break path from File name or spec }
function parsePath(path : string) : string;
var
current : string;
drive : word;
begin
if pos(':',path) = 0 then
drive := 0
else
begin
drive := byte(path[1]) - 64;
delete(path,1,pos(':',path));
end;
getDir(drive,current);
if path = '' then
begin
if current[length(current)] = '\' then
parsePath := current
else
parsePath := current + '\'
end
else
begin
case path[1] of
'\' : parsePath := copy(current,1,2) + path;
'.' : begin
while pos('..\',path) > 0 do
begin
delete(path,1,3);
delete(current,length(current),1);
while current[length(current)] <> '\' do
delete(current,length(current),1);
end;
parsePath := current + path;
end;
else begin
if current[length(current)] = '\' then
parsePath := current + path
else
parsePath := current + '\' + path;
end;
end;
end;
end;
begin
path := fileSpec;
if (pos('\',fileSpec) = 0) and (pos(':',fileSpec) = 0) then
path := ''
else
begin
while (path[length(path)] <> ':') and (path[length(path)] <> '\') do
delete(path,length(path),1);
end;
extractPath := parsePath(path);
end;
function params(var path,fileSpec : string; var mask : attrArray) : boolean;
var
i : word; { read parameters passed with fa2 and set changes }
s : string;
begin
if ParamCount = 0 then
params := false
else
begin
for i := 1 to ParamCount do
begin
s := ParamStr(i);
s := upcaseStr(s);
case s[1] of { if flag to change then change }
'+',
'-' : MarkChange(s[1],s[2],mask);
else fileSpec := s;
end;
end;
if fileSpec = '' then
params := false
else
begin
params := true;
path := extractPath(fileSpec);
end;
end;
end;
function switch(attr : byte; mask : attrArray) : byte;
{ if change requested make it if not already exists }
begin
case mask[arc] of
on : Attr := Attr or archive;
off : Attr := Attr and (not archive);
end;
case mask[sys] of
on : Attr := Attr or sysFile;
off : Attr := Attr and (not sysFile);
end;
case mask[hid] of
on : Attr := Attr or hidden;
off : Attr := Attr and (not hidden);
end;
case mask[r_o] of
on : Attr := Attr or readOnly;
off : Attr := Attr and (not readOnly);
end;
switch := Attr;
end;
procedure bracket(msg : string);
begin
write('[',msg,'] ');
end;
procedure report(fileData : searchRec);
var
dateData : dateTime;
begin { report file name and attributes }
with fileData do
begin
write(' ',name);
for i := length(name) to 13 do
write(' ');
if attr and directory = directory then
write('<DIR> ')
else
write(' ');
if attr and archive = archive then
bracket('Arc');
if attr and sysFile = sysFile then
bracket('Sys');
if attr and hidden = hidden then
bracket('Hid');
if attr and readOnly = readOnly then
bracket('R-O');
writeln;
end;
end;
begin
writeln;
writeln('File Attribute Utility version 4.0 by Steve Trace');
writeln;
if not params(path,fileSpec,mask) then
syntaxError; { if no parameters print syntax }
if not DosVersionOk then
halt;
findFirst(fileSpec,anyFile,fData); { find 1st occurance of fileSpec }
if dosError = 0 then { if all well }
begin
writeln(' Directory of: ',path); { print path }
writeln;
repeat
with fData do
begin
if name[1] <> '.' then { if not a . or .. directory }
begin
inc(count);
if changeAttr then { if attribute change requested }
begin
origAttr := attr;
dir := (attr and directory) = directory;
if dir then
attr := switch(attr,mask) and (not (directory + archive + sysFile + readOnly))
else
attr := switch(attr,mask);
assign(f,path + name);
setFattr(f,attr);
if dir then
attr := attr or directory;
if attr <> origAttr then
inc(changed);
end; { requires assign(f,path + name)}
report(fData);
end;
end;
findNext(fData);
if not (dosError in [0,18]) then
error;
if (count mod 21) = 20 then
begin
write('Press <Enter> to continue');
readln;
end;
until dosError = 18; { until no more files found }
writeln;
writeln('Total files: ',count,' Total changed: ',changed)
end
else
error;
end.